home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / sunsuspend.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  6.5 KB  |  181 lines
  1. (herald sunsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (suspend obj out-spec x?)
  6.   (set (experimental?) x?)
  7.   (really-suspend obj out-spec 'o))
  8.  
  9. (define-constant RELOC-SIZE 8)
  10. (define-constant CYMBAL-SIZE 12)
  11. (define-constant OMAGIC #o407)
  12. (define-constant N_TEXT 4)
  13. (define-constant N_DATA 6)
  14. (define-constant N_UNDF 0)
  15. (define-constant N_EXT 1)
  16.  
  17. (define (vgc-foreign foreign)
  18.   (let* ((heap (lstate-impure *lstate*))
  19.          (addr (+area-frontier heap))
  20.          (name (foreign-name foreign))
  21.          (desc (object nil
  22.                  ((heap-stored self) (lstate-impure *lstate*))
  23.                  ((heap-offset self) addr)
  24.                  ((write-descriptor self stream)
  25.                   (write-data stream (fx+ addr tag/extend)))
  26.                  ((write-store self stream)
  27.                   (write-int stream header/foreign)
  28.                   (write-slot name stream)
  29.                   (write-int stream 0)))))
  30.     (set (+area-frontier heap) (fx+ addr 12))
  31.     (push (+area-objects heap) desc)
  32.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  33.     (generate-slot-relocation name (fx+ addr 4))
  34.     (cymbol-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  35.     (reloc-thunk (fixnum-logior (fixnum-ashl (lstate-symbol-count *lstate*) 8)
  36.                                 #x50)
  37.                  (fx+ addr 8))
  38.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  39.     desc))
  40.  
  41. (define (generate-slot-relocation obj slot-address)
  42.   (cond ((or (fixnum? obj) (immediate? obj)))
  43.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  44.          (reloc-thunk #x640 slot-address))
  45.         (else
  46.          (reloc-thunk #x440 slot-address))))
  47.             
  48.  
  49. (define (reloc-thunk type address)
  50.   (push (lstate-data-reloc *lstate*)
  51.         (cons address type)))
  52.  
  53. (define (text-relocation addr)
  54.   (reloc-thunk #x440 addr))
  55.  
  56. (define (data-relocation addr)
  57.   (reloc-thunk #x640 addr))
  58.         
  59.  
  60. (define (write-slot obj stream)
  61.   (cond ((fixnum? obj)
  62.          (write-fixnum stream obj))
  63.         ((immediate? obj)
  64.          (write-immediate stream obj))
  65.         ((null? obj)
  66.          (write-descriptor (lstate-null *lstate*) stream))
  67.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  68.          => (lambda (desc) (write-descriptor desc stream)))
  69.         (else
  70.          (error "bad immediate type ~s" obj))))
  71.  
  72. (define-integrable (write-int stream int)
  73.   (write-half stream (fixnum-ashr int 16))
  74.   (write-half stream int))
  75.                        
  76. (define-integrable (write-immediate stream imm)
  77.   (let ((int (descriptor->fixnum imm)))
  78.     (write-half stream (fixnum-ashr int 14))
  79.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  80.                                                      
  81. (define-integrable (write-scratch stream obj i)
  82.   (let ((offset (fixnum-ashl i 2)))
  83.     (write-half stream (mref-16-u obj offset))
  84.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  85.     
  86. (define-integrable (write-half stream int)
  87.   (vm-write-byte stream (fixnum-ashr int 8))
  88.   (vm-write-byte stream int))
  89.  
  90. ;(define-integrable (write-byte stream n)
  91. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  92.  
  93. (define-integrable (write-fixnum stream fixnum)
  94.   (write-half stream (fixnum-ashr fixnum 14))
  95.   (write-half stream (fixnum-ashl fixnum 2)))
  96.  
  97.  
  98. (define (cymbol-thunk stryng type value)
  99.  (push (lstate-symbols *lstate*)
  100.   (object (lambda (stream a)
  101.             ;; a is offset into stryng table
  102.             (write-int stream a)
  103.             (vm-write-byte stream type)
  104.             (vm-write-byte stream 0)       ; other
  105.             (write-half stream 0)       ; see <stab.h>                 
  106.             (if (fixnum? value)            ; undefined external (foreign)
  107.                 (write-int stream 0)
  108.                 (write-descriptor value stream)))
  109.           ((cymbol-thunk.stryng self) stryng))))
  110.  
  111. (define-operation (cymbol-thunk.stryng thunk))
  112.  
  113. (define-integrable (write-data stream int)
  114.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  115.  
  116. (define (make-global-cymbol proc name)
  117.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  118.        => (lambda (desc)                                
  119.             (cymbol-thunk (string-downcase! (symbol->string name))
  120.                           (fixnum-logior N_DATA N_EXT)
  121.                           desc)
  122.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  123.            
  124.       (else
  125.        (error "~s not defined" name))))
  126.  
  127.                                        
  128. (define (write-link-file stream)
  129.   (make-global-cymbol big_bang 'big_bang)
  130.   (make-global-cymbol interrupt_dispatcher 'interrupt_dispatcher)
  131.   (write-header     stream)
  132.   (write-area       stream (lstate-pure *lstate*))
  133.   (write-area       stream (lstate-impure *lstate*))
  134.   (write-relocation stream (lstate-data-reloc *lstate*))  
  135.   (write-cymbol&stryng-table stream (reverse (lstate-symbols *lstate*))))
  136.  
  137. (define (write-header stream)
  138.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  139.          (data-size (+area-frontier (lstate-impure *lstate*))))
  140.     (write-half stream 2)                     ; only on mc68020
  141.     (write-half stream OMAGIC)                ;magic number
  142.     (write-int stream text-size)              ;text segment size
  143.     (write-int stream data-size)              ;data segment size
  144.     (write-int stream 0)                      ;bss  segment size
  145.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  146.     (write-int stream 0)                      ;bogus entry point
  147.     (write-int stream 0)                      ; no text relocation
  148.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  149.  
  150. (define (write-area stream area)
  151.   (walk (lambda (x) (write-store x stream))
  152.         (reverse! (+area-objects area))))
  153.  
  154.  
  155. (define (write-relocation stream items)
  156.   (walk (lambda (item)
  157.           (write-int stream (car item))
  158.           (write-int stream (cdr item)))
  159.         items))
  160.           
  161.                              
  162. (define (write-cymbol&stryng-table stream cyms)
  163.   (let ((z (write-cyms stream cyms))) ; cymbal table
  164.     (write-int stream z)       ; size of stryng table
  165.     (walk (lambda (s)             ; write stryng table
  166.             (write-string stream (cymbol-thunk.stryng s))
  167.             (vm-write-byte stream 0))
  168.            cyms)))
  169.  
  170. (define (write-cyms stream cyms)
  171.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  172.                  (l cyms))
  173.     (cond ((null? l) a)
  174.           (else
  175.            (let ((e (car l)))
  176.              (e stream a)
  177.              (loop (fx+ (fx+ a (string-length (cymbol-thunk.stryng e))) 1) ;null
  178.                    (cdr l)))))))
  179.  
  180.  
  181.